home *** CD-ROM | disk | FTP | other *** search
/ PC World Interactive 7 / PC World Interactive 7.iso / program / pasprog.EXE / PLASMA.PAS < prev    next >
Pascal/Delphi Source File  |  1996-06-28  |  4KB  |  155 lines
  1. {$I-}
  2. program plasma;
  3.  
  4.   uses
  5.     Crt,Dos;
  6.  
  7.   const
  8.     F = 3.0; { adjust for "roughness" of image }
  9.  
  10.   type
  11.     ColorValue = record Rvalue,Gvalue,Bvalue: byte; end;
  12.     PaletteType = array [0..255] of ColorValue;
  13.  
  14.   var
  15.     ch: char;
  16.     i: integer;
  17.     p: PaletteType;
  18.     image: file;
  19.     ok: boolean;
  20.  
  21.   procedure SetVGApalette(var tp: PaletteType);
  22.     var regs: Registers;
  23.   begin { procedure SetVGApalette }
  24.     with regs do
  25.       begin
  26.         AX:=$1012;
  27.         BX:=0; { first register to set }
  28.         CX:=256; { number of registers to set }
  29.         ES:=Seg(tp); DX:=Ofs(tp);
  30.       end;
  31.     Intr($10,regs);
  32.   end; { procedure SetVGApalette }
  33.  
  34.   procedure PutPixel(x,y: integer; c: byte);
  35.   begin { procedure PutPixel }
  36.     mem[$A000:word(320*y+x)]:=c;
  37.   end; { procedure PutPixel }
  38.  
  39.   function GetPixel(x,y: integer): byte;
  40.   begin { function GetPixel }
  41.     GetPixel:=mem[$A000:word(320*y+x)];
  42.   end; { function GetPixel }
  43.  
  44.   procedure adjust(xa,ya,x,y,xb,yb: integer);
  45.     var
  46.       d: integer;
  47.       v: real;
  48.   begin { procedure adjust }
  49.     if GetPixel(x,y)<>0 then exit;
  50.     d:=Abs(xa-xb)+Abs(ya-yb);
  51.     v:=(GetPixel(xa,ya)+GetPixel(xb,yb))/2+(random-0.5)*d*F;
  52.     if v<1 then v:=1;
  53.     if v>=193 then v:=192;
  54.     PutPixel(x,y,Trunc(v));
  55.   end; { procedure adjust }
  56.  
  57.  
  58.   procedure subDivide(x1,y1,x2,y2: integer);
  59.     var
  60.       x,y: integer;
  61.       v: real;
  62.   begin { procedure subDivide }
  63.     if KeyPressed then exit;
  64.     if (x2-x1<2) and (y2-y1<2) then exit;
  65.  
  66.     x:=(x1+x2) div 2;
  67.     y:=(y1+y2) div 2;
  68.  
  69.     adjust(x1,y1,x,y1,x2,y1);
  70.     adjust(x2,y1,x2,y,x2,y2);
  71.     adjust(x1,y2,x,y2,x2,y2);
  72.     adjust(x1,y1,x1,y,x1,y2);
  73.  
  74.     if GetPixel(x,y)=0 then
  75.       begin
  76.        
  77. v:=(GetPixel(x1,y1)+GetPixel(x2,y1)+GetPixel(x2,y2)+GetPixel(x1,y2))/4;
  78.         PutPixel(x,y,Trunc(v));
  79.       end;
  80.  
  81.     subDivide(x1,y1,x,y);
  82.     subDivide(x,y1,x2,y);
  83.     subDivide(x,y,x2,y2);
  84.     subDivide(x1,y,x,y2);
  85.   end; { procedure subDivide }
  86.  
  87.   procedure rotatePalette(var p: PaletteType; n1,n2,d: integer);
  88.     var
  89.       q: PaletteType;
  90.   begin { procedure rotatePalette }
  91.     q:=p;
  92.     for i:=n1 to n2 do
  93.       p[i]:=q[n1+(i+d) mod (n2-n1+1)];
  94.     SetVGApalette(p);
  95.   end; { procedure rotatePalette }
  96.  
  97. begin
  98.   Inline($B8/$13/0/$CD/$10); { select video mode 13h (320x200 with 256
  99. colors) }
  100.  
  101.   with p[0] do               { set background palette entry to grey }
  102.     begin
  103.       Rvalue:=32;
  104.       Gvalue:=32;
  105.       Bvalue:=32;
  106.     end;
  107.  
  108.   for i:=0 to 63 do { create the color wheel }
  109.     begin
  110.       with p[i+1] do begin Rvalue:=i; Gvalue:=63-i; Bvalue:=0; end;
  111.       with p[i+65] do begin Rvalue:=63-i; Gvalue:=0; Bvalue:=i; end;
  112.       with p[i+129] do begin Rvalue:=0; Gvalue:=i; Bvalue:=63-i; end;
  113.     end;
  114.  
  115.   SetVGApalette(p);
  116.  
  117.   Assign(image,'PLASMA.IMG');
  118.   Reset(image,1);
  119.   ok:=(ioResult=0);
  120.  
  121.   if not ok or (ParamCount<>0) then { create a new image }
  122.     begin
  123.       Randomize;
  124.  
  125.       PutPixel(0,0,1+Random(192));
  126.       PutPixel(319,0,1+Random(192));
  127.       PutPixel(319,199,1+Random(192));
  128.       PutPixel(0,199,1+Random(192));
  129.  
  130.       subDivide(0,0,319,199);
  131.  
  132.       Rewrite(image,1);
  133.       BlockWrite(image,mem[$A000:0],$FA00);
  134.     end
  135.   else { use the previous image }
  136.     BlockRead(image,mem[$A000:0],$FA00);
  137.  
  138.   Close(image);
  139.  
  140.   repeat
  141.     rotatePalette(p,1,192,+1);
  142.   until KeyPressed;
  143.  
  144.   ch:=ReadKey; if ch=#0 then ch:=ReadKey;
  145.  
  146.   TextMode(LastMode);
  147. end.
  148. {
  149. If you have code to share with me, just e-mail me and send me some!
  150. I'd love to trade code with other programmers and receive good
  151. criticism on my coding so far.  Enjoy!
  152.                                         - Splice
  153. }
  154.  
  155.